;; An sdl based gui in lisp optimized for psychology experiments

(in-package #:gwee)

(defvar *top-view* nil
  "The top level view for the sdl display.")

(defvar *gwee-base-pathname* nil
  "Where to look for data such as the button images.")

(defvar *resource-base-pathname* nil
  "Where to look for data from the program using this library.")

(defvar *default-background-color* nil)
(defvar *default-foreground-color* nil)

(defun relative-pathname (x)
  (format nil "~a~a" *gwee-base-pathname* x))

(defvar *top-level-dir-override* nil)

(defun top-level-dir ()
  *resource-base-pathname*)

(defun top-level-path (relative-path)
  (assert (not (eq (first (pathname-directory relative-path)) :absolute))
          ()
          "absolute paths don't work with TOP-LEVEL-PATH")
  (let ((base (top-level-dir)))
    ;; lots of SDL stuff want a namestring
    (namestring (make-pathname :directory (append (pathname-directory base)
                                                  (cdr (pathname-directory relative-path)))
                               :name (pathname-name relative-path)
                               :type (pathname-type relative-path)
                               :version (pathname-version relative-path)
                               :defaults base))))

(defun resource (filename)
  (format nil "~a~a" *resource-base-pathname* filename))

(defmacro define-slot-updater (class slot)
  (u:with-gensyms (value obj)
    `(defmethod (setf ,slot) :after (,value (,obj ,class))
       (setf (gwee:view-needs-update-p ,obj) t))))

(defclass size-hints-mixin ()
  ((minimum-width :initarg :minimum-width :accessor minimum-width)
   (minimum-height :initarg :minimum-height :accessor minimum-height)
   (maximum-width :initarg :maximum-width :accessor maximum-width)
   (maximum-height :initarg :maximum-height :accessor maximum-height)
   (best-x :type (or integer (member :current :left :right :center)) :initform :left :initarg :x :accessor best-x
           :documentation "A hint for the X position.")
   (best-y :type (or integer (member :current :top :bottom :center)) :initform :top :initarg :y :accessor best-y)
   (best-width :type (or list integer (member :current :maximum :minimum)) :initform :maximum :initarg :width :accessor best-width)
   (best-height :type (or list integer (member :current :maximum :minimum)) :initform :maximum :initarg :height :accessor best-height))
  (:documentation "Size hints"))

;; (defgeneric compute-best-width (view for)
;;   (:documentation "if VIEW was a subview of FOR, then what would it's best width be?"))
;; (defgeneric compute-best-height (view for)
;;   (:documentation "if VIEW was a subview of FOR, then what would it's best height be?"))

(defgeneric synchronize-subview-dimensions (view)
  (:documentation "This is called on a view when the layout changes
and a new position or size might be desirable for its subviews. VIEW's
dimensions should not change."))

(defgeneric synchronize-dimensions (view parent x y width height)
  (:documentation "Set VIEW's position and size according to the rectangular constraints."))

(defmethod synchronize-position (view parent x y))
(defmethod synchronize-x-left (view parent x y))
(defmethod synchronize-x-right (view parent x y))
(defmethod synchronize-x-center (view parent x y))
(defmethod synchronize-y-top (view parent x y))
(defmethod synchronize-y-bottom (view parent x y))
(defmethod synchronize-y-center (view parent x y))

(defgeneric synchronize-size (view parent width height))
(defgeneric synchronize-height-maximum (view parent width height))
(defgeneric synchronize-height-minimum (view parent width height))
(defgeneric synchronize-width-maximum (view parent width height))
(defgeneric synchronize-width-minimum (view parent width height))

(defclass view-cache ()
  ((top-x :accessor view-cache-top-x)
   (top-y :accessor view-cache-top-y)))

(defclass view (event-hooks-mixin view-cache size-hints-mixin)
  ((x :accessor view-x)
   (y :accessor view-y)
   (scroll-x :initform 0 :initarg :scroll-x :accessor view-scroll-x)
   (scroll-y :initform 0 :initarg :scroll-y :accessor view-scroll-y)
   (width :accessor view-width)
   (height :accessor view-height)
   (name :initform nil :initarg :name :accessor view-name)
   (parent :initform nil :initarg :parent :accessor view-parent)
   (subviews :initform nil :initarg :subviews :accessor view-subviews)))

(defgeneric view-bottom (view))
(defgeneric view-right (view))
(defgeneric (setf view-bottom) (value view))
(defgeneric (setf view-right) (value view))

(defmethod view-right (view)
  (+ (view-x view) (view-width view)))

(defmethod view-bottom (view)
  (+ (view-y view) (view-height view)))

(defmethod (setf view-bottom) (value view)
  (setf (view-y view) (- value (view-height view))))

(defmethod (setf view-right) (value view)
  (setf (view-x view) (- value (view-width view))))

(defgeneric view-visible-subviews (view)
  (:documentation "Return any subviews that could possibly be
visible. Normally this is all of them."))

(defgeneric find-subview-at (view x y))

(defmethod print-object ((obj view) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (name x y width height scroll-x scroll-y) obj
      (format stream "~s ~d ~d ~d ~d [~d ~d]" name
              (when (slot-boundp obj 'x) x)
              (when (slot-boundp obj 'y) y)
              (when (slot-boundp obj 'width) width)
              (when (slot-boundp obj 'height) height)
              (when (slot-boundp obj 'scroll-x) scroll-x)
              (when (slot-boundp obj 'scroll-y) scroll-y)))))

(defun cascade-cache-update-x (view)
  (dolist (i (view-subviews view))
    (when (slot-boundp i 'x)
      (setf (view-cache-top-x i) (translate-x-to-top (view-x i) view))
      (cascade-cache-update-x i))))

(defun cascade-cache-update-y (view)
  (dolist (i (view-subviews view))
    (when (slot-boundp i 'y)
      (setf (view-cache-top-y i) (translate-y-to-top (view-y i) view))
      (cascade-cache-update-y i))))

(defmethod (setf view-x) :after (n (view view))
  (when (view-parent view)
    (setf (view-cache-top-x view) (translate-x-to-top n (view-parent view))))
  (cascade-cache-update-x view)
  (run-hook-with-args (move-hook view) view :x))

(defmethod (setf view-y) :after (n (view view))
  (when (view-parent view)
    (setf (view-cache-top-y view) (translate-y-to-top n (view-parent view))))
  (cascade-cache-update-y view)
  (run-hook-with-args (move-hook view) view :y))

(defmethod (setf view-scroll-x) :after (n (view view))
  (cascade-cache-update-x view)
  (run-hook-with-args (scroll-hook view) view :x))

(defmethod (setf view-scroll-y) :after (n (view view))
  (cascade-cache-update-y view)
  (run-hook-with-args (scroll-hook view) view :y))

(defmethod (setf view-width) :after (n (view view))
  (setf (view-needs-sync-p view) t)
  (run-hook-with-args (resize-hook view) view :width))

(defmethod (setf view-height) :after (n (view view))
  (setf (view-needs-sync-p view) t)
  (run-hook-with-args (resize-hook view) view :height))

(defmethod find-subview-at ((view view) x y)
  (loop for i in (reverse (view-visible-subviews view))
     when (and (>= x (view-x i))
               (>= y (view-y i))
               (< x (+ (view-x i)
                       (view-width i)))
               (< y (+ (view-y i)
                       (view-height i))))
     do (return (or (find-subview-at i
				     (- x (- (view-x i) (view-scroll-x i)))
				     (- y (- (view-y i) (view-scroll-y i))))
		    i))))


(defun center-x (view)
  (setf (view-x view) (truncate (- (view-width (view-parent view)) (view-width view)) 2)))

(defun center-y (view)
  (setf (view-y view) (truncate (- (view-height (view-parent view)) (view-height view)) 2)))

(defun center (view)
  "Center the view within its parent"
  (center-x view)
  (center-y view))

(defmacro dimension-dispatch (dim a b dim-a dim-b &optional center allow-lists)
  (let ((best (find-symbol (u:concat 'best- dim) :gwee))
        (sync-a (find-symbol (u:concat 'synchronize- dim '- a) :gwee))
        (sync-b (find-symbol (u:concat 'synchronize- dim '- b) :gwee))
        (sync-c (find-symbol (u:concat 'synchronize- dim '- 'center) :gwee))
        (cur (find-symbol (u:concat 'view- dim) :gwee))
        (i (gensym "I")))
    (labels ((walk (how)
               `(loop for ,i in (cdr (,best view))
                     ,how (etypecase ,i
                            (number ,i)
                            (symbol
                             (ecase ,i
                               (,a (,sync-a view parent ,dim-a ,dim-b))
                               (,b (,sync-b view parent ,dim-a ,dim-b))))))))
      `(etypecase (,best view)
         (number
          (,best view))
         (symbol
          (ecase (,best view)
            (:current (,cur view))
            ,@(when center
                    `((:center (,sync-c view parent ,dim-a ,dim-b))))
            (,a (,sync-a view parent ,dim-a ,dim-b))
            (,b (,sync-b view parent ,dim-a ,dim-b))))
         ,@(when allow-lists
                 `((list
                   (ecase (first (,best view))
                     (< ,(walk 'minimizing))
                     (> ,(walk 'maximizing))))))))))

;;            (loop for ,i in (cdr (,best view))
;;               maximizing (etypecase ,i
;;                            (number ,i)
;;                            (symbol
;;                             (ecase ,i
;;                               (,a (,sync-a view parent ,dim-a ,dim-b))
;;                               (,b (,sync-b view parent ,dim-a ,dim-b))))))))))))

(defun synchronize-x (view parent x y) 
  (dimension-dispatch x :left :right x y t))

(defun synchronize-y (view parent x y) 
  (dimension-dispatch y :top :bottom x y t))

(defmethod synchronize-position ((view view) (parent view) x y)
  (setf (view-x view) (synchronize-x view parent x y)
        (view-y view) (synchronize-y view parent x y)))

(defmethod synchronize-x-left ((view view) (parent view) x y)
  x)

(defmethod synchronize-x-right ((view view) (parent view) x y)
  (- (view-width parent) (view-width view)))

(defmethod synchronize-x-center ((view view) (parent view) x y)
  (truncate (- (view-width parent) (view-width view)) 2))

(defmethod synchronize-y-top ((view view) (parent view) x y)
  y)

(defmethod synchronize-y-bottom ((view view) (parent view) x y)
  (- (view-height parent) (view-height view)))

(defmethod synchronize-y-center ((view view) (parent view) x y)
  (truncate (- (view-height parent) (view-height view)) 2))

(defun synchronize-width (view parent width height) 
  (dimension-dispatch width :minimum :maximum width height nil t))

(defun synchronize-height (view parent width height) 
  (dimension-dispatch height :minimum :maximum width height nil t))

(defmethod synchronize-size ((view view) (parent view) width height)
  (setf (slot-value view 'width) (synchronize-width view parent width height)
        (slot-value view 'height) (synchronize-height view parent width height)))

(defmethod synchronize-width-minimum ((view view) (parent view) width height)
  (warn "No minimum width is defined. Defaulting to maximum.")
  width)

(defmethod synchronize-width-maximum ((view view) (parent view) width height)
  width)

(defmethod synchronize-height-minimum ((view view) (parent view) width height)
  (warn "No minimum height is defined. Defaulting to maximum.")
  height)

(defmethod synchronize-height-maximum ((view view) (parent view) width height)
  height)

(defmethod synchronize-dimensions ((view view) (parent view) x y width height)
  (synchronize-size view parent width height)
  (synchronize-position view parent x y))

(defmethod synchronize-subview-dimensions ((view view))
  (dolist (i (view-subviews view))
    (synchronize-dimensions i view
                            0 0
                            (view-width view)
                            (view-height view)))
  (dolist (i (view-subviews view))
    (synchronize-subview-dimensions i)))

(defun funcall-on-view (function &optional view)
  (funcall function view)
  (dolist (i (view-subviews view))
    (funcall-on-view function i)))

(defclass top (view)
  ((mouse-graps :initform nil :accessor top-mouse-grabs)
   (keyboard-graps :initform nil :accessor top-keyboard-grabs)
   (force-update :initform nil :accessor top-force-update)
   (views-needing-update :initform nil :accessor views-needing-update)
   (views-needing-synchronizing :initform nil :accessor views-needing-synchronizing)
   ;; these behave a bit different in TOP
   (top-x :initform 0 :accessor view-cache-top-x)
   (top-y :initform 0 :accessor view-cache-top-y)
   (x :initform 0 :accessor view-x)
   (y :initform 0 :accessor view-y)
   (width :initarg :width :accessor view-width)
   (height :initarg :height :accessor view-height)
   (event-poll-hook :initform (make-instance 'hook) :accessor event-poll-hook)
   (suppress-drawing-p :initform nil :accessor suppress-drawing-p))
  (:documentation "The top level view."))

(defun view-needs-update-p (view)
  (and (find view (views-needing-update *top-view*)) t))

(defun view-needs-sync-p (view)
  (and (find view (views-needing-synchronizing *top-view*)) t))

(defgeneric (setf view-needs-update-p) (state view)
  (:documentation "Call on a view to notify gwee that it needs to be redrawn."))
(defgeneric (setf view-needs-sync-p) (state view)
  (:documentation "Call on a view to notify gwee that its dimensions need resynchronizing."))

(defmethod (setf view-needs-update-p) (state (view view))
  (if state
      (pushnew view (views-needing-update *top-view*))
      (setf (views-needing-update *top-view*) (delete view (views-needing-update *top-view*)))))

(defmethod (setf view-needs-sync-p) (state (view view))
  (if state
      (pushnew view (views-needing-synchronizing *top-view*))
      (setf (views-needing-synchronizing *top-view*) (delete view (views-needing-synchronizing *top-view*)))))

(defun force-update ()
  "Force a screen update whether any views are tagged as needing an
update. This can be helpful if a view decides to draw itself directly
instead of flagging itself for redraw."
  (setf (top-force-update *top-view*) t))

(defmethod initialize-instance :after ((view view) &key parent subviews)
  ;; keep the tree sane.
  (when (and parent
             (not (find view (view-subviews parent))))
    (setf (slot-value parent 'subviews) (append (view-subviews parent) (list view))
          (view-needs-sync-p parent) t))
  (dolist (i subviews)
    (setf (slot-value i 'parent) view))
  ;; make hints and dimensions work more intuitively
  (macrolet ((fix-best (best slot)
               `(when (numberp (,best view))
                  (setf (slot-value view ',slot) (,best view)
                        (,best view) :current)))
             ;; FIXME: legacy code expects the width and height to be filled in
             ;; with a maximum size when they are left unbound. Really the
             ;; default best-width/height should be set to :maximum by default
             (fix-size (best slot)
               `(when (and (eq (,best view) :current)
                           (not (slot-boundp view ',slot)))
                  (setf (,best view) :maximum))))
    (fix-best best-x x)
    (fix-best best-y y)
    (fix-best best-width width)
    (fix-best best-height height)
    (fix-size best-width width)
    (fix-size best-height height)))

(defmethod (setf view-parent) :before (parent view)
  (when (and (slot-boundp view 'parent)
             (view-parent view))
    (setf (slot-value (view-parent view) 'subviews) (delete view (slot-value (view-parent view) 'subviews))
          (view-needs-update-p (view-parent view)) t
          (view-needs-sync-p (view-parent view)) t)
    (run-hook-with-args (subviews-hook (view-parent view)) (view-parent view) nil (list view))))

;; FIXME: What if the new parent isn't in the view tree?
(defmethod (setf view-parent) :after (parent view)
  (unless (find view (view-subviews parent))
    (setf (slot-value parent 'subviews) (append (view-subviews parent) (list view))
          (view-needs-update-p parent) t
          (view-needs-sync-p parent) t)
    (run-hook-with-args (subviews-hook (view-parent view)) (view-parent view) (list view) nil)
    ))

(defmethod (setf view-subviews) :before (views parent)
  "Perform the housekeeping to ensure the tree structure remains
consistent."
  ;; XXX: a common pattern is (setf (view-subviews view) (delete
  ;; some-view view)) but DELETE is destructive and changes the actual
  ;; list, so this function won't be able to use the old list to
  ;; figure out which ones are missing and clean up after them.
  (let ((gone (set-difference (view-subviews parent) views)))
    (dolist (i gone)
      (setf (slot-value i 'parent) nil)
      (clear-grabs-for i)
      (remove-children-for-update i))
    (dolist (i views)
      (setf (slot-value i 'parent) parent))
    (setf (view-needs-update-p parent) t)
    ;; Some views change size when their subviews change so the
    ;; parent's parent needs syncing to ensure parent gets the right
    ;; size.
    (when (view-parent parent)
      (setf (view-needs-sync-p (view-parent parent)) t))))

(defmethod (setf view-subviews) :around (views parent)
  (let ((old (copy-list (view-subviews parent))))
    (call-next-method)
    (run-hook-with-args (subviews-hook parent) parent
			(set-difference (view-subviews parent) old)
			(set-difference old (view-subviews parent)))))

(defun all-subviews (view)
  (when view
    (cons view
	  (mapcan 'all-subviews (view-subviews view)))))

(defun clear-grabs-for (view)
  "If the view or child has a mouse or keyboard grab, then clear
it. Used for views that have been removed from the view tree."
  (setf (top-mouse-grabs *top-view*) (delete-if (lambda (x)
                                                  (or (eq view x)
                                                      (ancestor-p view x)))
                                                (top-mouse-grabs *top-view*)))
  (setf (top-keyboard-grabs *top-view*) (delete-if (lambda (x)
                                                     (or (eq view x)
                                                         (ancestor-p view x)))
                                                   (top-keyboard-grabs *top-view*))))

(defun remove-children-for-update (view)
  (setf (views-needing-update *top-view*)
	(nset-difference (views-needing-update *top-view*) (all-subviews view))))

(defun delete-view (view)
  "Remove view from the display tree."
  (when (and (view-parent view)
	     (find view (view-subviews (view-parent view))))
    (setf (slot-value (view-parent view) 'subviews) (delete view (view-subviews (view-parent view)))
	  (view-needs-update-p (view-parent view)) t
	  (slot-value view 'parent) nil)
    ;; clean out any views that are flagged for update but whose
    ;; ancestor just got deleted.
    (clear-grabs-for view)
    (remove-children-for-update view)))

(defun delete-views-if (function parent)
  (dolist (i (loop for v in (gwee:view-subviews parent)
                when (funcall function v)
                collect v))
    (delete-view i)))

(defun replace-view (from to)
  "Slightly faster than (setf view-subviews) when replacing a single view."
  (let ((parent (view-parent from)))
    (when parent
      (setf (nth (position from (view-subviews parent)) (view-subviews parent)) to
            (slot-value from 'parent) nil
            (slot-value to 'parent) parent
            (view-needs-update-p parent) t
            (view-needs-sync-p parent) t)
      (clear-grabs-for from)
      (remove-children-for-update from))))

(defclass widget (view)
  ((disabled-p :initform nil :initarg :disabled-p :accessor disabled-p)))

(define-slot-updater widget disabled-p)

(defclass background-mixin ()
  ((background-color :initform *default-background-color* :initarg :background :accessor background-color)
   (border-color :initform nil :initarg :border-color :accessor border-color)
   (border-left :initform 1 :initarg :border-left :accessor border-left)
   (border-right :initform 1 :initarg :border-right :accessor border-right)
   (border-top :initform 1 :initarg :border-top :accessor border-top)
   (border-bottom :initform 1 :initarg :border-bottom :accessor border-bottom))
  (:documentation "Mix this into your class to get a background color and a border"))

(define-slot-updater background-mixin background-color)
(define-slot-updater background-mixin border-color)
(define-slot-updater background-mixin border-left)
(define-slot-updater background-mixin border-right)
(define-slot-updater background-mixin border-top)
(define-slot-updater background-mixin border-bottom)

(defclass foreground-mixin ()
  ((foreground-color :initform *default-foreground-color* :initarg :foreground :accessor foreground-color)
   (font :initform (default-font) :initarg :font :accessor view-font)))

(define-slot-updater background-mixin foreground-color)
(define-slot-updater background-mixin view-font)

(defclass data-mixin ()
  ((data :initform nil :initarg :data :accessor view-data)
   (format-function :initform nil :initarg :format-function :accessor view-format-function)))

(define-slot-updater data-mixin view-data)

(defgeneric format-data (view &optional data))

(defmethod format-data ((view data-mixin) &optional (data (view-data view)))
  (if (view-format-function view)
      (funcall (view-format-function view) data)
      data))

(defclass callback-mixin ()
  ((click-callback :initform nil :initarg :click-callback :accessor click-callback)
   (callback-data :initarg :callback-data :accessor callback-data))
  (:documentation "Inherit this for standard callbacks"))

(defclass title-mixin ()
  ((title-text :initarg :title :accessor title-text))
  (:documentation "Inherit for a title"))

(defclass margin-mixin ()
  ((margin-top :initform 0 :initarg :margin-top :accessor margin-top)
   (margin-bottom :initform 0 :initarg :margin-bottom :accessor margin-bottom)
   (margin-left :initform 0 :initarg :margin-left :accessor margin-left)
   (margin-right :initform 0 :initarg :margin-right :accessor margin-right)))

(define-slot-updater margin-mixin margin-top)
(define-slot-updater margin-mixin margin-bottom)
(define-slot-updater margin-mixin margin-left)
(define-slot-updater margin-mixin margin-right)

(defmethod shared-initialize :before ((view margin-mixin) slot-names
                                     &key (margin nil margin-supplied))
  (when margin-supplied
    (setf (slot-value view 'margin-top) margin
          (slot-value view 'margin-bottom) margin
          (slot-value view 'margin-left) margin
          (slot-value view 'margin-right) margin)))

(defclass offset-mixin ()
  ((vertical-offset :initarg :vertical-offset :initform 0 :accessor vertical-offset :documentation
 "Use this to shift the view contents vertically.")
   (horizontal-offset :initarg :horizontal-offset :initform 0 :accessor horizontal-offset :documentation
 "Use this to shift the view contents horizontally."))
  (:documentation "It can sometimes be handy to be able to shift the contents of a view around. This is mostly used when font glyphs draw too low."))

(define-slot-updater offset-mixin vertical-offset)
(define-slot-updater offset-mixin horizontal-offset)

;; (defun translate-coordinates-to-top (x y from)
;;   (if (null (view-parent from))
;;       (values x y)
;;       (translate-coordinates-to-top
;;        (+ (view-x from)
;; 	  (- (view-scroll-x from))
;; 	  x)
;;        (+ (view-y from)
;; 	  (- (view-scroll-y from))
;; 	  y)
;;        (view-parent from))))

(defun translate-coordinates-to-top (x y from)
  (labels ((translate (view)
             (loop while view do
                  (incf x (- (view-x view)
                             (view-scroll-x view)))
                  (incf y (- (view-y view)
                             (view-scroll-y view)))
                  (setf view (view-parent view)))))
    (translate from)
    (values x y)))

(defmacro translate-position-macro (dim from)
  `(if ,from
       (,(find-symbol (u:concat 'translate- dim '-to-top) :gwee)
         (+ ,dim (- (,(find-symbol (u:concat 'view- dim) :gwee) ,from)
                    (,(find-symbol (u:concat 'view-scroll- dim) :gwee) ,from)))
         (view-parent ,from))
       ,dim))

(defun translate-x-to-top (x from)
  (translate-position-macro x from))

(defun translate-y-to-top (y from)
  (translate-position-macro y from))

(defun translate-coordinates (x y from &optional to)
  ;; get them both into the same space and subtract.
  (multiple-value-setq (x y) (translate-coordinates-to-top x y from))
  (if to
      (multiple-value-bind (fx fy) (translate-coordinates-to-top 0 0 to)
	(values (- x fx) (- y fy)))
      (values x y)))

(defun translate-x-coordinate (x from &optional to)
  (if to
      (- (translate-x-to-top x from)
         (translate-x-to-top 0 to))
      (translate-x-to-top x from)))

(defun translate-y-coordinate (y from &optional to)
  (if to
      (- (translate-y-to-top y from)
         (translate-y-to-top 0 to))
      (translate-y-to-top y from)))

(defun translate-view-position (view)
  (translate-coordinates-to-top (view-x view) (view-y view) (view-parent view)))

(defun view-to-top-x (view ofs)
  (+ (view-cache-top-x view)
     (- (view-scroll-x view))
     ofs))

(defun view-to-top-y (view ofs)
  (+ (view-cache-top-y view)
     (- (view-scroll-y view))
     ofs))

(defun top-to-view-x (view x)
  (- x
     (view-cache-top-x view)
     (- (view-scroll-x view))))

(defun top-to-view-y (view y)
  (- y
     (view-cache-top-y view)
     (- (view-scroll-y view))))


(defgeneric draw-view (view))

(defmacro with-clipping (view &body body)
  (let ((rect (gensym))
        (x1 (gensym))
        (y1 (gensym))
        (x2 (gensym))
        (y2 (gensym))
        (left (gensym))
        (top (gensym))
        (right (gensym))
        (bottom (gensym)))
    `(let* ((,rect (sdl:get-clip-rect))
            (,x1 (+ (view-cache-top-x ,view) (view-width ,view)))
            (,y1 (+ (view-cache-top-y ,view) (view-height ,view)))
            (,x2 (+ (sdl:x ,rect) (sdl:width ,rect)))
            (,y2 (+ (sdl:y ,rect) (sdl:height ,rect)))
            (,left (max (sdl:x ,rect) (view-cache-top-x ,view)))
            (,top (max (sdl:y ,rect) (view-cache-top-y ,view)))
            (,right (min ,x1 ,x2))
            (,bottom (min ,y1 ,y2)))
       (sdl:set-clip-rect (sdl:rectangle :x ,left :y ,top
                                         :w (max (- ,right ,left) 0)
                                         :h (max (- ,bottom ,top) 0)))
       (unwind-protect
            (progn ,@body)
         (sdl:set-clip-rect ,rect)))))

(defmethod draw-view :around ((view view))
  "Constrain drawing to the view's area."
  (with-clipping view
    (call-next-method)))

(defmethod draw-view ((view view))
  (mapc 'draw-view (view-subviews view)))

(defmethod draw-view :before ((view background-mixin))
  (when (background-color view)
    (when (and (plusp (view-width view))
	       (plusp (view-height view)))
      (sdl:draw-box-* (view-cache-top-x view) (view-cache-top-y view)
		      (view-width view) (view-height view)
		      :color (background-color view)))))

(defmethod draw-view :after ((view background-mixin))
  (when (border-color view)
    ;; fine-grained border control
    (when (border-top view)
      (sdl:draw-hline (view-cache-top-x view)
                      (+ (view-cache-top-x view) (view-width view) -1)
                      (view-cache-top-y view)
                      :color (border-color view)))
    (when (border-bottom view)
      (sdl:draw-hline (view-cache-top-x view)
                      (+ (view-cache-top-x view) (view-width view) -1)
                      (+ (view-cache-top-y view) (view-height view) -1)
                      :color (border-color view)))
      (when (border-left view)
        (sdl:draw-vline (view-cache-top-x view)
                        (view-cache-top-y view)
                        (+ (view-cache-top-y view) (view-height view) -1)
                        :color (border-color view)))
      (when (border-right view)
        (sdl:draw-vline (+ (view-cache-top-x view) (view-width view) -1)
                        (view-cache-top-y view)
                        (+ (view-cache-top-y view) (view-height view) -1)
                        :color (border-color view)))))

(defun redraw-gui ()
  (draw-view *top-view*))

(defstruct key
  sym mod)
  
(defun sdlmod-to-list (mod)
  (let (acc)
    (labels ((add-mod (kw mod-sym)
	       (when (plusp (logand mod (cffi:foreign-enum-value 'sdl-cffi::sdl-mod kw)))
		 (push mod-sym acc))))
      ;;(add-mod :SDL-KEY-MOD-NONE)
      (add-mod :SDL-KEY-MOD-LSHIFT :shift)
      (add-mod :SDL-KEY-MOD-RSHIFT :shift)
      (add-mod :SDL-KEY-MOD-LCTRL :control)
      (add-mod :SDL-KEY-MOD-RCTRL :control)
      (add-mod :SDL-KEY-MOD-LALT :alt)
      (add-mod :SDL-KEY-MOD-RALT :alt)
      (add-mod :SDL-KEY-MOD-LMETA :meta)
      (add-mod :SDL-KEY-MOD-RMETA :meta)
      ;; FIXME: just ignore numlock?
      ;;(add-mod :SDL-KEY-MOD-NUM :numlock)
      (add-mod :SDL-KEY-MOD-CAPS :caplock)
      (add-mod :SDL-KEY-MOD-MODE :mode)
      ;;(add-mod :SDL-KEY-MOD-RESERVED)
      acc)))

(defgeneric key-press-event (view key))
(defgeneric key-release-event (view key))
(defgeneric mouse-press-event (view button x y))
(defgeneric mouse-release-event (view button x y))
(defgeneric mouse-motion-event (view state x y xrel yrel))
(defgeneric mouse-enter-event (view state x y xrel yrel))
(defgeneric mouse-leave-event (view state x y xrel yrel))
;;(defgeneric dispatch-mouse-enter/leave-events (view in-now in-before state x y xrel yrel))

;; go through the subviews in reverse so that those that are drawn
;; last and most likely to be visible capture the event first.

(defmethod key-press-event ((view view) key)
  (loop for i in (reverse (view-visible-subviews view))
       until (key-press-event i key)))

(defmethod key-release-event (view key)
  (loop for i in (reverse (view-visible-subviews view))
       until (key-release-event i key)))

(defmethod mouse-press-event (view button x y)
  "coordinates are translated to be relative to view."
  (loop for i in (reverse (view-visible-subviews view))
     ;; Only find the first matching subview and call
     ;; it on that. This prevents overlapping views from both getting
     ;; a press event.
     when (and (> x (view-x i))
               (> y (view-y i))
               (< x (+ (view-x i)
                       (view-width i)))
               (< y (+ (view-y i)
                       (view-height i))))
     do (return (mouse-press-event i button
                                   (- x (- (view-x i) (view-scroll-x i)))     ; (translate-x-coordinate x view i)
                                   (- y (- (view-y i) (view-scroll-y i))))))) ; (translate-y-coordinate y view i)))))

(defmethod mouse-release-event (view button x y)
  "coordinates are translated to be relative to view."
  (loop for i in (reverse (view-visible-subviews view))
     when (and (> x (view-x i))
               (> y (view-y i))
               (< x (+ (view-x i)
                       (view-width i)))
               (< y (+ (view-y i)
                       (view-height i))))
     do (return (mouse-release-event i button
                                        (- x (- (view-x i) (view-scroll-x i))) ; (translate-x-coordinate x view i)
                                        (- y (- (view-y i) (view-scroll-y i))))))) ; (translate-y-coordinate y view i)))))

(defmethod mouse-motion-event (view state x y xrel yrel)
  (loop for i in (reverse (view-visible-subviews view))
     when (and (> x (view-x i))
               (> y (view-y i))
               (< x (+ (view-x i)
                       (view-width i)))
               (< y (+ (view-y i)
                       (view-height i))))
     do (return (mouse-motion-event i state
                                    (- x (- (view-x i) (view-scroll-x i))) ;(translate-x-coordinate x view i)
                                    (- y (- (view-y i) (view-scroll-y i))) ;(translate-y-coordinate y view i)
                                    xrel yrel))))

(defmethod mouse-enter-event ((view view) state x y xrel yrel)
  )

(defmethod mouse-leave-event ((view view) state x y xrel yrel)
  )

(defun find-common-ancestor (v1 v2)
  ;; XXX: I'm sure there are faster/better algorithms but this works.
  (let ((v1-parents (loop for i = v1 then (view-parent i)
		       while i collect i))
	(v2-parents (loop for i = v2 then (view-parent i)
		       while i collect i)))
    (loop for i in v1-parents
	 when (find i v2-parents)
	 return i)))

(defun dispatch-mouse-enter/leave-events (top state x y xrel yrel)
  (unless (top-mouse-grabs top)
    ;; FIXME: implement it for grabs!
    (let* ((now (find-subview-at top x y))
	   (before (find-subview-at top (- x xrel) (- y yrel)))
	   (ancestor (find-common-ancestor now before)))
      ;;(print (list 'abc now before ancestor))
      ;;(finish-output)
      (unless (eq now before)
        (labels ((collect (from)
                   (loop for p = from then (view-parent p)
                      until (eq p ancestor)
                      collect p)))
          ;; the hook can alter parents so callect them first, then run through them.
          (let ((leave-parents (collect before))
                (enter-parents (reverse (collect now))))
            (loop for p in leave-parents
               do (mouse-leave-event p state (top-to-view-x p x) (top-to-view-y p y) xrel yrel)
               (run-hook-with-args (leave-hook p) p x y state))
            (loop for p in enter-parents
               do (mouse-enter-event p state (top-to-view-x p x) (top-to-view-y p y) xrel yrel)
               (run-hook-with-args (enter-hook p) p x y state))))))))

;; (defmethod dispatch-mouse-enter/leave-events (view in-now in-before state x y xrel yrel)
;;   (labels ((inside-p (x y v)
;; 	     (and (>= x (view-x v))
;; 		  (>= y (view-y v))
;; 		  (< x (+ (view-x v)
;; 			  (view-width v)))
;; 		  (< y (+ (view-y v)
;; 			  (view-height v))))))
;;     (when (and (not in-now)
;; 	       in-before)
;;       (run-hook-with-args (leave-hook view) view state))
;;     ;; check the subviews
;;     (loop
;;        with oldx = (- x xrel)
;;        with oldy = (- y yrel)
;;        for i in (reverse (view-subviews view))
;;        ;; If the pointer isn't in VIEW before or now then it can't be for a subview
;;        for now = (and in-now (inside-p x y i))
;;        for before = (and in-before (inside-p oldx oldy i))
;;        when (or now before)
;;        do (dispatch-mouse-enter/leave-events i now before state
;; 					     (- x (- (view-x i) (view-scroll-x i)))
;; 					     (- y (- (view-y i) (view-scroll-y i)))
;; 					     xrel yrel))
;;     (when (and in-now
;; 	       (not in-before))
;;       (run-hook-with-args (enter-hook view) view state))))

;;; The grab override functions. FIXME: Best way to do it? Possibly it
;;; would be better to just override it before calling these
;;; functions.

(defmethod mouse-press-event :around ((top top) button x y)
  (if (top-mouse-grabs top)
      (mouse-press-event (first (top-mouse-grabs top)) button
                         (translate-x-coordinate x top (first (top-mouse-grabs top)))
                         (translate-y-coordinate y top (first (top-mouse-grabs top))))
      (call-next-method)))

(defmethod mouse-release-event :around ((top top) button x y)
  (if (top-mouse-grabs top)
      (mouse-release-event (first (top-mouse-grabs top)) button
                           (translate-x-coordinate x top (first (top-mouse-grabs top)))
                           (translate-y-coordinate y top (first (top-mouse-grabs top))))
      (call-next-method)))

(defmethod mouse-motion-event :around ((top top) state x y xrel yrel)
  (if (top-mouse-grabs top)
      (mouse-motion-event (first (top-mouse-grabs top)) state
                          (translate-x-coordinate x top (first (top-mouse-grabs top)))
                          (translate-y-coordinate y top (first (top-mouse-grabs top)))
                          xrel yrel)
      (call-next-method)))

;; (defmethod dispatch-mouse-enter/leave-events :around ((top top) in-now in-before state x y xrel yrel)
;;   (if (top-mouse-grabs top)
;;       (dispatch-mouse-enter/leave-events (first (top-mouse-grabs top))

;; 					 in-now in-before
;; 					 state x y xrel yrel)
;;       (call-next-method)))

(defmethod key-press-event :around ((top top) key)
  (if (top-keyboard-grabs top)
      (key-press-event (first (top-keyboard-grabs top)) key)
      (call-next-method)))

(defmethod key-release-event :around ((top top) key)
  (if (top-keyboard-grabs top)
      (key-release-event (first (top-keyboard-grabs top)) key)
      (call-next-method)))

(defun read-state (state)
  ;;(format t "state is: ~a~%" state)
  (cond ((eql state 0) :up)
	((eql state 1) :down)
	(t (error "whoaH!"))))

(defun read-button-state (state)
  ;; these values were gathered from SDL_mouse.h
  (let (buttons)
    (labels ((add (idx sym)
	       (when (plusp (logand state (ash 1 idx)))
		 (push sym buttons))))
      (add 0 :left)
      (add 1 :middle)
      (add 2 :right)
      (add 3 :wheel-up)
      (add 4 :wheel-down)
      buttons)))

(defun ancestor-p (ancestor view)
  (or (eq ancestor (view-parent view))
      (and (view-parent view)
           (ancestor-p ancestor
                       (view-parent view)))))

(defun find-ancestor-if (fn view)
  (and (view-parent view)
       (or (and (funcall fn (view-parent view))
		(view-parent view))
	   (find-ancestor-if fn (view-parent view)))))

;;   (loop for i = (view-parent view)
;;        while i
;;        when (eq i ancestor) (return t)))

(defun siblings (view)
  (when (view-parent view)
    (remove view (view-subviews (view-parent view)))))

(defun inside-view-p (v x y)
  "X,Y are assumed to be in V's parent view space."
  (and (>= x (view-x v))
       (>= y (view-y v))
       (< x (+ (view-x v)
               (view-width v)))
       (< y (+ (view-y v)
               (view-height v)))))

(defun views-overlap-p (v1 v2)
  (let ((x1 (view-cache-top-x v1))
        (y1 (view-cache-top-y v1))
        (x2 (view-cache-top-x v2))
        (y2 (view-cache-top-y v2)))
    (not
     (and (> x1
             (+ x2 (view-width v2)))
          (> y1
             (+ y2 (view-height v2)))
          (> x2
             (+ x1 (view-width v1)))
          (> y2
             (+ y1 (view-height v1)))))))

(defun view-overlap-rect-p (v1 x1 y1 x2 y2)
  (let ((x (view-cache-top-x v1))
        (y (view-cache-top-y v1)))
    (not
     (and (> x x2)
          (> y y2)
          (> x1 (+ x (view-width v1)))
          (> y1 (+ y (view-height v1)))))))

(defun overlapping-ancestor-siblings (view)
  (let* ((x1 (view-cache-top-x view))
         (y1 (view-cache-top-y view))
         (x2 (+ x1 (view-width view)))
         (y2 (+ y1 (view-height view))))
    (labels ((walk (current)
               (when (view-parent current)
                 (nconc
                  (walk (view-parent current))
                  (loop for s in (siblings current)
                     when (view-overlap-rect-p s x1 y1 x2 y2)
                     collect s)))))
      (walk view))))

(defun view-overlapping-views (view views)
  "Return the views in VIEWS that overlap view."
  (let* ((x1 (view-cache-top-x view))
         (y1 (view-cache-top-y view))
         (x2 (+ x1 (view-width view)))
         (y2 (+ y1 (view-height view))))
    (loop for s in views
       when (view-overlap-rect-p s x1 y1 x2 y2)
       collect s)))

(defmethod view-visible-subviews (view)
  (view-subviews view))

(defun overlapping-siblings (view)
  "return the visible siblings of view that overlap it."
  ;; FIXME: I don't like that we have to check this everytime when it
  ;; only happens for *top-view* and we should be able to catch it
  ;; earlier.
  (when (view-parent view)
    (view-overlapping-views view (view-visible-subviews (view-parent view)))))

(defun sync-views (&optional view)
  (labels ((walk (top)
             (if (find top (views-needing-synchronizing *top-view*))
                 (synchronize-subview-dimensions top)
                 (mapc #'walk (view-subviews top)))))
    (let ((save (views-needing-update *top-view*)))
      (if view
          (synchronize-subview-dimensions view)
          (when (views-needing-synchronizing *top-view*)
            (walk *top-view*)
            ;;(synchronize-subview-dimensions *top-view*)
            (setf (views-needing-synchronizing *top-view*) nil)))
      (setf (views-needing-update *top-view*) save))))

(defun update-display ()
  (sdl:update-display))

(defun update-views ()
  (labels ((walk (top &optional force-redraw)
;;              (with-clipping top
               (if (or force-redraw
                       (find top (views-needing-update *top-view*)))
                   (progn
                     (draw-view top)
                     ;;(setf (views-needing-update *top-view*) (append (overlapping-siblings top) (views-needing-update *top-view*)))
                     t)
                   (loop
                      for v in (view-visible-subviews top)
                      for redraw = (walk v (view-overlapping-views v redrawn))
                      when redraw collect v into redrawn
                      finally (return (and redrawn t))))))
  ;; remove any views whose ancestors are already in the list
;;   (setf (views-needing-update *top-view*)
;;         (delete-if (lambda (y)
;;                      (find-if (lambda (x)
;;                                 (ancestor-p x y))
;;                               (views-needing-update *top-view*)))
;;                    (views-needing-update *top-view*)))
;;   ;; Any views being drawn whose siblings or siblings of ancestors
;;   ;; that overlap should also be redrawn
    (sync-views)
    (unless (suppress-drawing-p *top-view*)
      (setf (views-needing-update *top-view*)
            (delete-duplicates
             (nconc
              (views-needing-update *top-view*)
              (mapcan (lambda (x) (overlapping-siblings x)) (views-needing-update *top-view*)))))
      (walk *top-view* (top-force-update *top-view*))
      (when (or (views-needing-update *top-view*)
                (top-force-update *top-view*))
        (update-display))
      (setf (views-needing-update *top-view*) nil
            (top-force-update *top-view*) nil))))

;;; TODO: I think grabs should only be nested if the view being
;;; grabbed is a child of the currently grabbed view. If not the
;;; view's grab is simply removed.

(defun grab-mouse (view)
  "Make all mouse press/release/motion events be sent only to the
specified view until another view grabs the mouse or it is ungrabbed.

The mouse grab is a stack. Old grabs are not removed but just put on
hold until the current grab expires. Therefore, for every grab there
MUST be a corresponding ungrab, or the grab list becomes corrupted.

Generally the with-mouse macro is used to ensure the grab list doesn't
get corrupted."
  (push view (top-mouse-grabs *top-view*)))

(defun ungrab-mouse (&optional view)
  "deliver mouse events according to the old rules. If VIEW is
supplied, then remove all instances of VIEW from the grab
list. Otherwise pop the latest grab."
  (if view
      (setf (top-mouse-grabs *top-view*) (delete view (top-mouse-grabs *top-view*)))
      (pop (top-mouse-grabs *top-view*))))

(defmacro with-mouse (view &body body)
  "Reroute all mouse events to the specified VIEW while executing BODY."
  `(unwind-protect
	(progn
	  (grab-mouse ,view)
	  ,@body)
     (ungrab-mouse ,view)))

(defun grab-keyboard (view)
  "Make all key press/release events be sent only to the specified
view until another view grabs the keyboard or it is ungrabbed.

The keyboard grab is a stack. Old grabs are not removed but just put
on hold until the current grab expires. Therefore, for every grab
there MUST be a corresponding ungrab, or the grab list becomes
corrupted.

Generally the with-keyboard macro is used to ensure the grab list
doesn't get corrupted."
  (push view (top-keyboard-grabs *top-view*)))

(defun ungrab-keyboard (&optional view)
  "deliver keyboard events according to the old rules. If VIEW is
supplied, then remove all instances of VIEW from the grab
list. Otherwise pop the latest grab."
  (if view
      (setf (top-keyboard-grabs *top-view*) (delete view (top-keyboard-grabs *top-view*)))
      (pop (top-keyboard-grabs *top-view*))))

(defmacro with-keyboard (view &body body)
  "Reroute all keyboard events to the specified VIEW while executing BODY."
  `(unwind-protect
	(progn
	  (grab-keyboard ,view)
	  ,@body)
     (ungrab-keyboard ,view)))

(defmacro with-events (view &body body)
  "Report all events only to VIEW while executing BODY."
  `(unwind-protect
	(progn
	  (grab-keyboard ,view)
	  (grab-mouse ,view)
	  ,@body)
     (ungrab-keyboard ,view)
     (ungrab-mouse ,view)))

(defvar *idle-queue* nil
  "The list of functions and args to run in when the event loop is
idle.")

(defvar *idle-queue-lock* (make-lock)
  "the idle queue lock.")

(defvar *idle-queue-gate* (mp:make-gate nil))

(defvar *idle-queue-ret-gate* (mp:make-gate nil))

(defvar *gwee-process* nil)

(defun enqueue (fn &rest args)
  "Add code to be run when the event loop is idle."
  (with-lock (*idle-queue-lock*)
    (setf *idle-queue* (append *idle-queue* `((,fn ,@args)))))
  ;;(mp:process-revoke-arrest-reason *gwee-process* :waiting-for-events)
  )

(defun clear-idle-queue ()
  (with-lock (*idle-queue-lock*)
    (setf *idle-queue* nil)))

(defvar *timer-list* nil
  "List of active timers.")

(defvar *timer-hook* nil
  "Called whenever a timer expires.")

(defun default-add-timer (timer)
  (setf *timer-list* (sort-timers (cons timer *timer-list*))))

(defvar *add-timer-function* #'default-add-timer)

(defstruct timer
  time delay repeat function args)

(defun run-with-timer (secs repeat function &rest args)
  "Perform an action after a delay of SECS seconds.
Repeat the action every REPEAT seconds, if repeat is non-nil.
SECS and REPEAT may be reals.
The action is to call FUNCTION with arguments ARGS."
  (check-type secs (real 0 *))
  (check-type repeat (or null (real 0 *)))
  (check-type function (or function symbol))
  (let ((timer (make-timer
                :delay (truncate (* secs internal-time-units-per-second))
                :repeat (when repeat
			  (truncate (* repeat internal-time-units-per-second)))
                :function function
                :args args)))
    (schedule-timer timer (timer-delay timer))
    (funcall *add-timer-function* timer)
    timer))

(defun cancel-timer (timer)
  "Remove TIMER from the list of active timers."
  (check-type timer timer)
  (setf *timer-list* (remove timer *timer-list*)))

(defun now ()
  (get-internal-real-time))

(defun delay (ms)
  (sdl-cffi::sdl-delay ms))

(defun schedule-timer (timer when)
  (setf (timer-time timer) (+ (now) when)))

(defun absolute-timer-event (time function)
  (setf *timer-list* (sort-timers (cons (make-timer :time time
                                                    :function function)
                                        *timer-list*))))

(defun push-timers-ahead (ms)
  (dolist (i *timer-list*)
    (incf (timer-time i) ms)))

(defun cancel-all-timers ()
  (setf *timer-list* nil))

(defun sort-timers (timers)
  "Return a new list of timers sorted by time to time out."
  (sort (copy-list timers)
        (lambda (a b)
          (< (timer-time a) (timer-time b)))))

(defun default-run-expired-timers ()
  "Return a new list of valid timers and run the timer functions
of those expired."
  (let ((now (now))
        keepers expired)
    (loop for i in *timer-list* do
         (if (<= (timer-time i) now)
             (progn
               (push i expired)

               (when (timer-repeat i)
                 (schedule-timer i (timer-repeat i))
                 (push i keepers)))
             (push i keepers)))
    ;; a timer callback may schedule a new timer, so do it such a way
    ;; that those new timers are not lost.
    (setf *timer-list* (sort-timers keepers))
    (dolist (i expired)
      (when *timer-hook*
        (funcall *timer-hook* i))
      (apply (timer-function i) (timer-args i)))
    expired))

(defvar *expired-timers-function* nil
  "To override the regular expired timers function, use this instead.")

(defun run-expired-timers ()
  (if *expired-timers-function*
      (funcall *expired-timers-function*)
      (default-run-expired-timers)))

(defun update-expired-animations (&aux (now (now)))
  (labels ((do-animation (view)
             (when (and (typep view 'animation-mixin)
                        (animation-interval view)
                        (or (not (animation-last-update view))
                            (<= (+ (animation-last-update view) (animation-interval view))
                                now)))
               (update-animation view)
               (setf (animation-last-update view) now))
             (mapc #'do-animation (view-visible-subviews view))))
    (when *top-view*
      (do-animation *top-view*))))

(defun get-next-timeout (&optional (timers *timer-list*))
  "Return the number of seconds until the next timeout or nil if there are no timers or animation views."
  (let ((now (now))
        update
        animation)
    (labels ((soonest-animation (view)
               (when (and (typep view 'animation-mixin)
                          (animation-interval view)
                          (or (not animation)
                              (< (animation-last-update view) update)))
                 (setf update (or (animation-last-update view) 0)
                       animation view))
               (mapc #'soonest-animation (view-visible-subviews view))))
      (soonest-animation *top-view*)
      (let ((next (when timers
                    (max (- (timer-time (car timers)) now)
                         0))))
        (cond
          ((and next animation)
           (min next (max (- update now) 0)))
          (next next)
          (animation
           (max (- update now) 0))
          (t nil))))))

(defun handle-queue ()
  (when *idle-queue*
    (with-lock (*idle-queue-lock*)
      (loop
        for i = (pop *idle-queue*)
        do (apply (car i) (cdr i))
        while *idle-queue*))
    t))

(defun handle-timers-and-queue ()
  (let (expired update)
    (setf expired (run-expired-timers)
          update (handle-queue))
    (when (or expired update)
      (update-views))
    update))

(defun handle-gui-events ()
  "Depricated."
  (dispatch-events))

(defun clear-event-queue (&optional (sleep 0))
  "Events that should be ignored can pile up and cause weirdness. This
function clears any events in the queue and can optionally wait for
SLEEP number of seconds, discarding any events that come in during
that time. The default is to discard and immediately return."
  (let* ((event (sdl:new-event))
	 (start (now))
	 (end (+ start (* sleep internal-time-units-per-second))))
    (loop
       for time = (now)
       for eventp = (plusp (sdl-cffi::sdl-poll-event event))
       while (or eventp
		 (or (not end)
		     (<= time end)))
       do
       ;; wait either a second or whatever is left before time-out,
       ;; whichever is smaller.
       (when (not eventp)
	 (let* ((now (now))
		(done (max 0 (/ (- end now)
				internal-time-units-per-second))))
	   (delay (truncate (* (min 1 done) 1000))))))))

(defvar *event-hook* nil
  "Set this to a function to get access to every single SDL event that comes in.")

(defvar *tick-hook* nil
  "Set this to a function that is called every on every polling tick in with-event-handler.")

(defvar *fake-event-hook* nil
  "Set this to a function that is called to add fake events to the
queue. This is for replaying events.")

(defun quit-event-p (event)
  (eql (cffi:foreign-enum-value 'sdl-cffi::Sdl-Event-Type :sdl-quit-event)
       (cffi:foreign-slot-value event 'sdl-cffi::sdl-event 'sdl-cffi::type)))

(defun poll-event (time event)
  (when *fake-event-hook*
    ;; gobble up real events so they don't interfere with fake
    ;; ones. Except we want to let through quit events.
    (loop for eventp = (plusp (sdl-cffi::sdl-poll-event event))
          while eventp
          when (quit-event-p event)
            do (throw 'quit nil))
    (funcall *fake-event-hook* time))
  (sdl-cffi::sdl-poll-event event))

(defun resize-window (width height)
  "Resize the SDL window. This only works if you passed :flags sdl:sdl-resizable to with-gui."
  (sdl:resize-window width height)
  (sdl:clear-display *default-background-color*)
  (setf (view-width *top-view*) width
	(view-height *top-view*) height)
  (synchronize-subview-dimensions *top-view*)
  (draw-view *top-view*)
  (setf (views-needing-update *top-view*) nil
        (views-needing-synchronizing *top-view*) nil)
  (update-display))

(defmacro with-event-handler ((&key timeout (poll 0.03) (update-views t)) &body body)
  ;; FIXME: timeout, poll and update-views should prolly be evaluated only once.
  (let ((time (gensym "TIME"))
	(start (gensym "START"))
	(eventp (gensym "EVENTP"))
	(end (gensym "END")))
    `(labels ((match-event (event type)
		(eql (cffi:foreign-enum-value 'sdl-cffi::Sdl-Event-Type type)
		     (cffi:foreign-slot-value event 'sdl-cffi::sdl-event 'sdl-cffi::type)))
	      (parse-key-event (event)
		(make-key :sym (cffi:foreign-slot-value (cffi:foreign-slot-pointer event
										   'sdl-cffi::sdl-keyboard-event
										   'sdl-cffi::keysym)
							'sdl-cffi::sdl-key-sym 'sdl-cffi::sym)
			  :mod (sdlmod-to-list (cffi:foreign-slot-value (cffi:foreign-slot-pointer event
												   'sdl-cffi::sdl-keyboard-event
												   'sdl-cffi::keysym)
									'sdl-cffi::sdl-key-sym 'sdl-cffi::mod)))))
       (let* ((%event% (sdl:new-event))
	      (,start (now))
	      (,end (and ,timeout (+ ,start (* ,timeout internal-time-units-per-second)))))
         (when ,update-views (update-views))
	 (loop
	    for ,time = (now)
	    for ,eventp = (plusp (poll-event ,time %event%))
	    ;; XXX: So long as there are events to process, keep
	    ;; processing. This means it overrides the timeout, which
	    ;; coul mean if there was a steady stream of events this
	    ;; function would never return. Should timeout override events?
	    while (or ,eventp
		      (or (not ,end)
			  (<= ,time ,end)))
	    do
	    (when ,eventp
              (when *event-hook*
                (funcall *event-hook* %event%))
	      ,@body)
	    (when ,update-views (update-views))
            (when *tick-hook*
              (funcall *tick-hook* ,time))
	    (when (handle-timers-and-queue)
              (mp:open-gate *idle-queue-ret-gate*))
            (update-expired-animations)
            (run-hook (event-poll-hook *top-view*))
	    ;; maybe wait around a bit before polling again.
	    (when (and (not ,eventp)
		       (plusp ,poll))
	      (let* ((now (now))
		     (poll-ms (truncate (* ,poll internal-time-units-per-second)))
		     (remainder (max 0 (- poll-ms (- now ,time))))
		     (next (get-next-timeout))
		     (timer (or next remainder))
		     (done (or (and ,end (max 0 (- ,end now))) remainder))
		     (amt (min remainder timer done)))
		(delay amt))))))))

;; (defmacro with-model-event-handler ((&key timeout (poll 0.03) (update-views t)) &body body)
;;   ;; FIXME: timeout, poll and update-views should prolly be evaluated only once.
;;   (let ((time (gensym "TIME"))
;; 	(start (gensym "START"))
;; 	(eventp (gensym "EVENTP"))
;; 	(end (gensym "END")))
;;     `(labels ((match-event (event type)
;; 		(eql (cffi:foreign-enum-value 'sdl-cffi::Sdl-Event-Type type)
;; 		     (cffi:foreign-slot-value event 'sdl-cffi::sdl-event 'sdl-cffi::type)))
;; 	      (parse-key-event (event)
;; 		(make-key :sym (cffi:foreign-slot-value (cffi:foreign-slot-pointer event
;; 										   'sdl-cffi::sdl-keyboard-event
;; 										   'sdl-cffi::keysym)
;; 							'sdl-cffi::sdl-key-sym 'sdl-cffi::sym)
;; 			  :mod (sdlmod-to-list (cffi:foreign-slot-value (cffi:foreign-slot-pointer event
;; 												   'sdl-cffi::sdl-keyboard-event
;; 												   'sdl-cffi::keysym)
;; 									'sdl-cffi::sdl-key-sym 'sdl-cffi::mod)))))
;;        (let* ((%event% (sdl:new-event))
;; 	      (,start (now))
;; 	      (,end (and ,timeout (+ ,start (* ,timeout internal-time-units-per-second)))))
;;          (when ,update-views (update-views))
;;          ;; clear events
;;          (loop while (or (not ,timeout)
;;                          (< (now) ,end))
;;                do (loop
;;                     for eventp = (plusp (sdl-cffi::sdl-poll-event %event%))
;;                     while eventp)
;; 		  ;; (unless (mp:gate-open-p *idle-queue-gate*)
;; 	       (mp:close-gate *idle-queue-gate*)
;; 	       (mp:open-gate *idle-queue-ret-gate*)
;; 	       ;;(mp:process-add-arrest-reason (current-process) :waiting-for-events)
;; 	       (mp:process-wait "Waiting for events" #'mp:gate-open-p *idle-queue-gate*)
;;                   (handle-queue)
;;                   (when ,update-views (update-views)))))))

(defun model-event-handler (timeout poll update-views
                            key-press
                            key-release
                            mouse-press
                            mouse-release
                            mouse-motion)
  (let* ((event (sdl:new-event))
         (start (now))
         (end (and timeout (+ start (* timeout internal-time-units-per-second)))))
    (when update-views (update-views))
    ;; clear events
    (loop while (or (not timeout)
                    (< (now) end))
          do (loop
               for eventp = (plusp (sdl-cffi::sdl-poll-event event))
               while eventp)
             ;; (unless (mp:gate-open-p *idle-queue-gate*)
             (mp:close-gate *idle-queue-gate*)
             (mp:open-gate *idle-queue-ret-gate*)
             ;;(mp:process-add-arrest-reason (current-process) :waiting-for-events)
             (mp:process-wait "Waiting for events" #'mp:gate-open-p *idle-queue-gate*)
             (handle-queue)
             (when update-views (update-views)))))

;; (defun parse-timing (tag string)
;;   (let ((match (second (multiple-value-list (ppcre:scan-to-strings "Timing the evaluation of (.*)

;; User time    =        (.*)
;; System time  =        (.*)
;; Elapsed time =        (.*)
;; Allocation   = (.*?) bytes
;; \(.*?) Page faults" string)))))
;;     (when (> (read-from-string (elt match 3)) 0.01)
;;       (format t "Timing for ~a: ~a~%" tag (elt match 3))
;;       (finish-output))))

(defun mouse-click-event-slots (event)
  (list (cffi:foreign-slot-value event 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::button)
        (cffi:foreign-slot-value event 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::x)
        (cffi:foreign-slot-value event 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::y)))

(defun key-event-slots (event)
  (list (cffi:foreign-slot-value (cffi:foreign-slot-pointer event
                                                            'sdl-cffi::sdl-keyboard-event
                                                            'sdl-cffi::keysym)
                                 'sdl-cffi::sdl-key-sym 'sdl-cffi::sym)
        (cffi:foreign-slot-value (cffi:foreign-slot-pointer event
                                                            'sdl-cffi::sdl-keyboard-event
                                                            'sdl-cffi::keysym)
                                 'sdl-cffi::sdl-key-sym 'sdl-cffi::mod)))

(defun mouse-motion-event-slots (event)
  (list
   (cffi:foreign-slot-value event 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::state)
   (cffi:foreign-slot-value event 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::x)
   (cffi:foreign-slot-value event 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::y)
   (cffi:foreign-slot-value event 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::xrel)
   (cffi:foreign-slot-value event 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::yrel)))

(defun resize-event-slots (event)
  (list (cffi:foreign-slot-value event 'sdl-cffi::Sdl-Resize-Event 'sdl-cffi::w)
        (cffi:foreign-slot-value event 'sdl-cffi::Sdl-Resize-Event 'sdl-cffi::h)))

(defun human-event-handler (timeout poll update-views
                            key-press
                            key-release
                            mouse-press
                            mouse-release
                            mouse-motion)
  (with-event-handler (:timeout timeout :poll poll :update-views update-views)
    (cond
      ((match-event %event% :sdl-key-down-event)
       (funcall key-press *top-view* (parse-key-event %event%)))
      ((match-event %event% :sdl-key-up-event)
       (funcall key-release *top-view* (parse-key-event %event%)))
      ((match-event %event% :sdl-mouse-button-down-event)
       (funcall mouse-press *top-view*
                (cffi:foreign-slot-value %event% 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::button)
                (cffi:foreign-slot-value %event% 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::x)
                (cffi:foreign-slot-value %event% 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::y)))
      ((match-event %event% :sdl-mouse-button-up-event)
       (funcall mouse-release *top-view*
                (cffi:foreign-slot-value %event% 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::button)
                (cffi:foreign-slot-value %event% 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::x)
                (cffi:foreign-slot-value %event% 'sdl-cffi::Sdl-Mouse-Button-Event 'sdl-cffi::y)))
      ((match-event %event% :sdl-mouse-motion-event)
       (funcall mouse-motion *top-view*
                (read-button-state (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::state))
                (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::x)
                (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::y)
                (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::xrel)
                (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::yrel))
       (update-views)
       (dispatch-mouse-enter/leave-events *top-view*
                                          (read-button-state (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::state))
                                          (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::x)
                                          (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::y)
                                          (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::xrel)
                                          (cffi:foreign-slot-value %event% 'sdl-cffi::SDL-Mouse-Motion-Event 'sdl-cffi::yrel)))
      ((match-event %event% :sdl-video-resize-event)
       (resize-window (cffi:foreign-slot-value %event% 'sdl-cffi::Sdl-Resize-Event 'sdl-cffi::w)
                      (cffi:foreign-slot-value %event% 'sdl-cffi::Sdl-Resize-Event 'sdl-cffi::h)))
      ((match-event %event% :sdl-quit-event)
       (throw 'quit nil))
      ((match-event %event% :sdl-video-expose-event)
       (update-display)))))

(defvar *event-handler-function* #'human-event-handler)

(defun dispatch-events (&key timeout (poll 0.03) (update-views t)
                          (key-press 'key-press-event)
                          (key-release 'key-release-event)
                          (mouse-press 'mouse-press-event)
                          (mouse-release 'mouse-release-event)
                          (mouse-motion 'mouse-motion-event))
  "Process any events that have queued up and return.

If TIMEOUT is a positive number then process events for that many
seconds before returning. If TIMEOUT is 0 then return immediately
after processing events. If TIMEOUT is nil then never return.

POLL determines the maximum amount of time that should pass before
checking for new events in seconds. 0 means busy-wait, which will
consume a bunch of CPU power. By default poll every 30th of a second."
  (funcall *event-handler-function*
           timeout poll update-views
           key-press key-release
           mouse-press mouse-release
           mouse-motion))

(defun fullscreen-p ()
  (let ((flags (sdl:surface-info sdl:*default-display*)))
    (find 'sdl-cffi::sdl-fullscreen flags)))

(defun resizable-p ()
  (let ((flags (sdl:surface-info sdl:*default-display*)))
    (find 'sdl-cffi::sdl-resizable flags)))

(defun toggle-fullscreen ()
  (let ((full (not (fullscreen-p))))
    (if full
        (sdl:resize-window (view-width *top-view*) (view-height *top-view*) :sw t :fullscreen t)
        (sdl:resize-window (view-width *top-view*) (view-height *top-view*) :sw t :resizable (resizable-p)))
    (setf sdl:*default-surface* sdl:*default-display*)
    (draw-view *top-view*)
    (setf (views-needing-update *top-view*) nil
          (views-needing-synchronizing *top-view*) nil)
    (update-display)))

(defgeneric get-mouse-state (view))
(defgeneric warp-mouse (view x y))

(defmethod get-mouse-state ((view null))
  "Return the absolute position and button state of the mouse."
  (cffi:with-foreign-objects ((x :int)
                              (y :int))
    (let ((buttons (sdl-cffi::sdl-get-mouse-state x y)))
      (values (cffi:mem-ref x :int) (cffi:mem-ref y :int)
              (read-button-state buttons)))))

(defmethod get-mouse-state ((view view))
  "Return the mouse position relative to VIEW."
  (multiple-value-bind (x y b) (get-mouse-state nil)
    (values (top-to-view-x view x)
            (top-to-view-y view y)
            b)))

(defmethod warp-mouse ((view view) x y)
  (sdl-cffi::sdl-warp-mouse (gwee:view-to-top-x view x) (gwee:view-to-top-y view y)))


(defun run-with-gui (function w h &key (title "Gwee") font (font-size 14) (foreground (gwee:gray 255)) (background (gwee:gray 0)) (resizable nil) (event-hook nil) (tick-hook nil) (fake-event-hook nil) (timer-hook nil) flags)
  (sdl:with-init (sdl:sdl-init-audio)
    (sdl-mixer:open-audio)
    (sdl-mixer::register-sample-finished-callback)
    (sdl:window w h :title-caption title :sw t :resizable resizable)
    (init-base-pathnames)
    (init-fonts font font-size)
    (init-button)
    (let ((*default-foreground-color* foreground)
          (*default-background-color* background)
          (*event-hook* event-hook)
          (*fake-event-hook* fake-event-hook)
          (*tick-hook* tick-hook)
          (*timer-hook* timer-hook)
          (*top-view* (make-instance 'top :width w :height h))
          (sdl:*default-surface* sdl:*default-display*))
      (setf *idle-queue* nil
            *timer-list* nil
            *gwee-process* (current-process))
      (sdl:clear-display (gray 0) :update t)
      (catch 'quit
        (handler-bind
            ((error #'crash-handler-helper))
          (funcall function)
          (synchronize-subview-dimensions *top-view*)
          (draw-view *top-view*)
          (setf (views-needing-update *top-view*) nil
                (views-needing-synchronizing *top-view*) nil)
          (update-display)
          (dispatch-events)))
      (setf *gwee-process* nil)))
  (sdl-mixer:halt-music)
  (sdl-mixer:close-audio t)
  (sdl-mixer::unregister-sample-finished-callback)
  ;; (exit)
  )

(defmacro with-gui ((w h &rest keys &key &allow-other-keys) &body body)
  `(run-with-gui (lambda () ,@body) ,w ,h ,@keys))

(defun debug-mode (&optional (resource-pathname #P"/Volumes/data/work/git/algebra-tutor.git/"))
  (defun init-base-pathnames () (setf *gwee-base-pathname* #P"c:/documents and settings/shawn betts/my documents/work/l1/gwee/"
				      *resource-base-pathname* resource-pathname))
  (defun exit ())
  (setf *crash-handler* nil))

(defun tester ()
  (with-gui (1024 768 :font "sans.ttf" :background (gwee:gray 255) :foreground (gwee:gray 0))
    (let ((b (make-instance 'button :x :center :y :center :width 100 :height 100  :data "click me!" :parent *top-view*)))
      (sync-views)
      (print `(x ,(view-x b) y ,(view-y b))))))
